Monster Media 1994 #2/Monster Media No. 2 (Monster Media)(1994).ISO/prog_bas/tblevw.zip/TABLE.TXT

Text File | 1994-04-29 | 6KB | 245 lines

Sub ExitApp ()

    ' Close database and table before exiting
    Tb.Close
    Db.Close
    End

End Sub

Sub ExitMenuOption_Click ()

    Unload Me

End Sub

Sub FieldLayout ()

    ' Get Field Layout to determine field display
    ' and data entry size
    For ct = 0 To Tb.Fields.Count - 1

        'Set display heading to database fieldname
        FldName = Tb.Fields(ct).Name
        Table1.ColumnName(ct + 1) = FldName

        'Get width of fieldname
        NameWidth = Len(FldName)

        'Get type of field to determine it's display size
        Select Case Tb.Fields(ct).Type
            Case 1, 10      'Text and Logic types
                FldSize = Tb.Fields(ct).Size
            Case 3          'Integer type
                FldSize = 7
            Case 4, 8       'Long and date types
                FldSize = 14
            Case 5, 6, 7    'Currency, Single, Double types
                FldSize = 10
            Case 11, 12     'Memo and binary types
                FldSize = 25
        End Select

        ' Use field width or the field name width whichever is larger
        If NameWidth > FldSize Then
            Table1.ColumnWidth(ct + 1) = NameWidth + 2
        Else
            Table1.ColumnWidth(ct + 1) = FldSize + 2
        End If

        ' Set data entry width to Field size
        Table1.ColumnSize(ct + 1) = FldSize
    Next ct

End Sub

Sub Form_Load ()

    ' Open Database and Table functions
    OpenDb ("market.mdb")
    OpenTb ("Contact_Info")

    ' Estimate begining size, put approx size in MAXROW
    EndRow = MAXROW
    ' Set grid Rows to estimated MAXROW
    Table1.Rows = MAXROW
    ' Set Current Row to one
    Temp = MoveToRow(1)

    ' Function to setup grids columns
    FieldLayout

End Sub

Sub Form_Resize ()

    ' Center the grid on the form
    Table1.Top = TableForm.ScaleTop + 50
    Table1.Left = TableForm.ScaleLeft + 50
    Table1.Height = TableForm.ScaleHeight - 100
    Table1.Width = TableForm.ScaleWidth - 100

End Sub

Sub Form_Unload (Cancel As Integer)

    ExitApp

End Sub

Function MoveToRow (NewRow As Long) As Long

Dim CurDiff, EndDiff, BeginDiff As Long

    ' Find differences between beginning, end and current position
    CurDiff = Abs(CurrentRow - NewRow)
    EndDiff = EndRow - NewRow
    BeginDiff = NewRow - 1

    ' If values are same no need to move db
    If CurrentRow = NewRow Then
        MoveToRow = CurrentRow
        Exit Function

    ' If moving forward in db
    ElseIf CurrentRow < NewRow Then

        ' Check to see if End is closer, if not
        ' move from current position to new position
        If EndDiff > CurDiff Then
            For ct = 1 To CurDiff
                Tb.MoveNext
                If Tb.EOF Then
                    CurrentRow = Tb.RecordCount
                    MoveToRow = CurrentRow
                    Exit Function
                Else
                    CurrentRow = CurrentRow + 1
                End If
            Next ct

        ' If end is closer move to the end of the database
        ' and go backwards to the new position
        Else
            Tb.MoveLast
            CurrentRow = Tb.RecordCount

            'Check to see if estimated equal actual, if not equal
            'exit function so CheckRows can set the actual EndRow value
            If EndRow = Tb.RecordCount Then
                For ct = 1 To EndDiff
                    Tb.MovePrevious
                    CurrentRow = CurrentRow - 1
                Next ct
            End If
        End If

    ' Moving backward in db
    Else

        ' If BeginDiff is greater than CurDiff then move
        ' from current position to new position
        If BeginDiff > CurDiff Then
            For ct = 1 To CurDiff
                Tb.MovePrevious
                If Tb.BOF Then
                    CurrentRow = 1
                    MoveToRow = CurrentRow
                    Exit Function
                Else
                    CurrentRow = CurrentRow - 1
                End If
            Next ct

        ' If beginning is closer then move from
        ' beginning to new position
        Else
            Tb.MoveFirst
            CurrentRow = 1
            For ct = 1 To BeginDiff
                Tb.MoveNext
                CurrentRow = CurrentRow + 1
            Next ct
        End If
    End If
    MoveToRow = CurrentRow

End Function

Sub OpenDb (DbName As String)

    ' Put your open database code here
    ChDir App.Path
    Set Db = OpenDatabase(DbName)

End Sub

Sub OpenTb (TableName As String)

    ' Put your open table code here
    Set Tb = Db.OpenTable(TableName)

End Sub

Sub Table1_CheckRows (RequestRows As Long, CurRows As Long)

    ' Move in table to value specified by RequestRows
    NewRow = MoveToRow(RequestRows)

    ' If table did not make it to the NewRow value
    ' i.e. NewRow was not attainable then
    ' end of db was reached
    If NewRow <> RequestRows Then
        ' Set CurRows to actual end of file
        CurRows = NewRow
        ' Set EndRow to actual end of file
        EndRow = NewRow
    End If

End Sub

Sub Table1_Fetch (row As Long, Col As Integer, Value As String)

    ' This condition should always be true because of the
    ' code in the CheckRows events but we double check
    NewRow = MoveToRow(row)
'    Debug.Print "OR=" & Str$(row)
'    Debug.Print "NR =" & Str$(NewRow)

    If NewRow = row Then

        ' If field is empty trap Null and use empty quotes instead
        If IsNull(Tb(Col - 1)) Then
            Value = ""
        Else
            Value = Tb(Col - 1)
        End If
    Else
        MsgBox "Error in navigating database"
    End If

End Sub

Sub Table1_Update (row As Long, Col As Integer, Value As String)

    ' This should always be true because of the code in the
    ' CheckRows but we double check anyways
    If MoveToRow(row) = row Then
        Call UpdateTable(Col, Value)
    Else
        MsgBox "Error updating value"
    End If

End Sub

Sub UpdateTable (Column As Integer, NewValue As String)

        ' There is no error checking so becareful
        ' of data mismatches!!!
        Tb.Edit
        Tb(Column - 1) = NewValue
        Tb.Update

End Sub